{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Ochre.Compiler.Syntax
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Two level syntax - pure values and effectful expressions.
--
--------------------------------------------------------------------------------

module Ochre.Compiler.Syntax
  (
    Orchestra(..)
  , GlobalStmt(..)
  , Instrument(..)
  , Decl(..)
  , Expr(..)
  , Value(..)
  
  , effect

  , ppInstr
  , ppExpr

  , FreeVars
  , freevars

  ) where

import Ochre.Compiler.Operators
import Ochre.Compiler.Utils
import Ochre.Compiler.VarId

import Text.PrettyExprHPJ                       -- package: pretty-expr-hpj
import Text.PrettyExprHPJ.Haskell98

import Text.PrettyPrint.HughesPJ            -- package: pretty

import qualified Data.Set as S


data Orchestra = Orchestra
    { orch_globals      :: [GlobalStmt]
    , orch_instrs       :: [Instrument]
    }
  deriving (Eq,Show)

data GlobalStmt = GlobalDecl VarId PrimId [Value]
                | GlobalOpCall0 PrimId [Value]           -- e.g. ZakInit
  deriving (Eq,Show)

data Instrument = Instrument
    { instr_num         :: Int
    , instr_decls       :: [Decl]
    , instr_body        :: Expr
    }
  deriving (Eq,Show)

data Decl = Decl VarId Value
  deriving (Eq,Show)

-- | Separation of Values and Expressions.
--
-- Bool helps const folding even though Csound doesn\'t have one.
-- 
data Value = Unit
           | Bool Bool
           | Int Int
           | Float Decimal
           | String String
           | Pfield Int
           | Var VarId
           | Signal VarId
           | UnaryV UnaryOp Value
           | BinV BinOp Value Value
           | RelV RelOp Value Value
           | CondV Value Value Value
           | FunCallV PrimId [Value]
  deriving (Eq,Show)


infixl 1 :>>

-- | Prim is prim-application.
--
data Expr = Return Value                        -- lift a pure Value (needed?)
          | OpCall PrimId [Value]
          | LetValue VarId Value Expr          -- float, int, bool, ...
          | LetSig1 VarId Expr Expr             -- ISig, KSig, ASig, ...
          | LetSig2 VarId VarId Expr Expr
          | LetSig3 VarId VarId VarId Expr Expr
          | LetSig4 VarId VarId VarId VarId Expr Expr
          | Ifte Value Expr Expr
          | WriteSig VarId Expr
          | Expr :>> Expr                       -- sequence
  deriving (Eq,Show)




-- 
-- Note - Csound if expressions must have a binary relational 
-- expression for the cond expression, the following
-- will not compile:
-- 
-- > if 0 then ...
--
-- The syntax allows this so we must do something in the 
-- translation...
--



-- | Note the type of a Opcode call (Prim) is its answer type
-- (i.e. the application of Prim to its arguments) not the type 
-- of the opcode function.
--
-- C.f. Haskell
--
-- > :t ( 1 + 2)  == Int  (Prim App)
-- 
-- > :t (+)       == Int -> Int -> Int (Prim Def)
--
--



-- | Sequencing is expected to be effectful oin the left...
--
effect :: Expr -> Bool
effect (Return {})              = False
effect (LetValue _ _ e1)        = effect e1
effect (LetSig1 _ e1 e2)        = effect e1 || effect e2
effect (Ifte _ e1 e2)           = effect e1 || effect e2
effect (e1 :>> e2)              = effect e1 || effect e2
effect _                        = True


--------------------------------------------------------------------------------
-- pretty print

ppInstr :: Instrument -> Doc
ppInstr (Instrument i decls expr) = 
    text "instr" <+> int i $+$ nest 2 (ds $+$ ppExpr expr)
  where
    ds = vcat $ map ppDecl decls

ppDecl :: Decl -> Doc
ppDecl (Decl var val) = 
    text "def" <+> (text $ varName var) <+> text " = " <+> ppValue val

ppExpr :: Expr -> Doc
ppExpr = unparse . exprDoc



exprDoc :: Expr -> DocE
exprDoc (Return v)                  = valueDoc v
exprDoc (OpCall v es)               = 
    funAppB (literal $ prim_name v) (map valueDoc es)

exprDoc (LetValue vid v1 e1)        = 
    let pre = text "let" <+> text (varName vid) 
    in Atom $ letBody pre (ppValue v1) (ppExpr e1)

exprDoc (LetSig1 vid e1 e2)         = 
    let pre = text "letsig" <+> text (varName vid)
    in Atom $ letBody pre (ppExpr e1) (ppExpr e2)

exprDoc (LetSig2 v1 v2 e1 e2)       = 
    let pre = text "letsig2" <+> tupled (map (text . varName) [v1,v2])
    in Atom $ letBody pre (ppExpr e1) (ppExpr e2)

exprDoc (LetSig3 v1 v2 v3 e1 e2)    = 
    let pre = text "letsig3" <+> tupled (map (text . varName) [v1,v2,v3])
    in Atom $ letBody pre (ppExpr e1) (ppExpr e2)

exprDoc (LetSig4 v1 v2 v3 v4 e1 e2) = 
    let pre = text "letsig4" <+> tupled (map (text . varName) [v1,v2,v3,v4])
    in Atom $ letBody pre (ppExpr e1) (ppExpr e2)

exprDoc (Ifte v1 e1 e2)             = 
    Atom $ text "if" <+> ppValue v1
                     <+> nest 2 (    text "then" <+> ppExpr e1
                                 $+$ text "else" <+> ppExpr e2)

exprDoc (WriteSig vid e)            = 
    updateRefB (literal $ varName vid)  (exprDoc e)

exprDoc (e1 :>> e2)                 = monadicSeqB (exprDoc e1) (exprDoc e2)  


ppValue :: Value -> Doc
ppValue = unparse . valueDoc

valueDoc :: Value -> DocE
valueDoc (Unit)                     = literal "()"
valueDoc (Bool True)                = Atom $ text "true" 
valueDoc (Bool False)               = Atom $ text "false"
valueDoc (Int i)                    = Atom $ int i
valueDoc (Float d)                  = Atom $ truncatedDouble $ realToFrac d
valueDoc (String ss)                = Atom $ doubleQuotes $ text ss
valueDoc (Pfield i)                 = literal $ 'p' : show i
valueDoc (Var v)                    = literal $ varName v 
valueDoc (Signal v)                 = literal $ varName v 
valueDoc (UnaryV op v)              = unaryDocE op (valueDoc v)
valueDoc (BinV op v1 v2)            = binDocE op (valueDoc v1) (valueDoc v2)
valueDoc (RelV relop v1 v2)         = 
    relDocE relop (valueDoc v1) (valueDoc v2)

valueDoc (CondV v1 vt vf)           = 
    Atom $ text "cond" <+> ppValue v1
                       <+> nest 2 (    text "then" <+> ppValue vt
                                   $+$ text "else" <+> ppValue vf)

valueDoc (FunCallV v es)            = 
    funAppB (literal $ prim_name v) (map valueDoc es)


letBody :: Doc -> Doc -> Doc -> Doc
letBody d e body = 
    d <+> char '=' <+> e <+> text "in" $+$ nest 2 body



--------------------------------------------------------------------------------
-- Free vars

type FreeVars = S.Set VarId

freevars :: Expr -> FreeVars
freevars (Return v)                     = freevarsV v
freevars (LetValue v val e2)            =
    S.union (freevarsV val) (S.delete v $ freevars e2)

freevars (LetSig1 v e1 e2)              =
    S.union (freevars e1) (S.delete v $ freevars e2)

freevars (LetSig2 v1 v2 e1 e2)          =
    let lhs = freevars e1
        rhs = S.delete v2 $ S.delete v1 $ freevars e2
    in S.union lhs rhs
                             
freevars (LetSig3 v1 v2 v3 e1 e2)       = 
    let lhs = freevars e1
        rhs = S.delete v3 $ S.delete v2 $ S.delete v1 $ freevars e2
    in S.union lhs rhs

freevars (LetSig4 v1 v2 v3 v4 e1 e2)    = 
    let lhs = freevars e1
        rhs = S.delete v4 $ S.delete v3 $ S.delete v2 $ S.delete v1 $ 
                freevars e2
    in S.union lhs rhs

freevars (OpCall _ xs)                  = S.unions $ map freevarsV xs

freevars (Ifte v1 e1 e2)                = 
    S.unions [freevarsV v1, freevars e1, freevars e2]

freevars (WriteSig v e)                 = S.insert v $ freevars e
freevars (e1 :>> e2)                    = S.union (freevars e1) (freevars e2)


freevarsV :: Value -> FreeVars
freevarsV (Var v)                = S.singleton v
freevarsV (Signal v)             = S.singleton v
freevarsV (UnaryV _ v)           = freevarsV v
freevarsV (BinV _ v1 v2)         = freevarsV v1 `S.union` freevarsV v2
freevarsV (RelV _ v1 v2)         = freevarsV v1 `S.union` freevarsV v2
freevarsV (CondV v1 vt vf)       = S.unions $ map freevarsV [v1,vt,vf]
freevarsV (FunCallV _ xs)        = S.unions $ map freevarsV xs
freevarsV _                      = S.empty

